home *** CD-ROM | disk | FTP | other *** search
/ Technotools / Technotools (Chestnut CD-ROM)(1993).ISO / lang_oth / lisp207 / extfunc.l next >
Lisp/Scheme  |  1986-03-25  |  4KB  |  124 lines
  1.  
  2. ;    Here is the example .l file. Load it into PC-LISP with the
  3. ; command (load 'extfunc) from the PC-LISP prompt. Then type
  4. ; (GraphicsDemo) from the prompt.
  5. ;
  6. ; EXTFUNC.L                             
  7. ; ~~~~~~~~~                             
  8. ;     A small library of functions to help fill in the gap between PC and      
  9. ; Franz Lisp. These functions are for learning purposes only are not very
  10. ; effectient or very robust. Also included is a set of turtle graphics
  11. ; commands that will work on just about any MS-DOS machine via the BIOS.  
  12. ;    
  13. ;        Peter Ashwood-Smith
  14.  
  15. (defun member(x y)(cond((null y)nil)((equal x(car y))y)(t(member x(cdr y]  
  16. (defun memq(x y)(cond((null y) nil)((eq x(car y))y)(t(memq x(cdr y]  
  17. (defun tailp(l1 l2)(cond ((null l2) nil)((eq l1 l2) l1)(t(tailp l1(cdr l2]  
  18. (defun arrayp(x) nil)        
  19. (defun bcdp(x) nil)        
  20. (defun bigp(x) nil)        
  21. (defun dtpr(x) (and(listp x)(atom (cdr x)]       
  22. (defun fixp(n) nil)
  23. (defun hunkp(n) nil)
  24. (defun litatom(n) (and(atom n)(not(floatp n]   
  25. (defun numbp(n) (floatp n))        
  26. (defun numberp(n) (floatp n))
  27. (defun purep(n)(or(eq n t)(eq n nil)(eq n 'lambda)(eq n 'nlambda)]  
  28. (defun stringp(n) nil)                    
  29. (defun symbolp(n) (litatom n))            
  30. (defun valuep(n) nil)
  31. (defun vectorp(n) nil)
  32. (defun typep(n)(type n))
  33. (defun eqstr(a b)(equal a b))
  34. (defun neq(a b)(not(eq a b)))
  35. (defun nequal(a b)(not(equal a b)))
  36. (defun append1(a b)(append a (list b)))
  37. (defun copy(a)(reverse(reverse a)))        
  38. (defun ncons(a)(cons a nil))
  39. (defun xcons(a b)(cons b a))
  40. (defun last(l)(nth (- (length l) 1) l))
  41. (defun nthcdr(n l)(cond((< n 0)(cons nil l))((= n 0)l)(t(nthcdr (- n 1)(cdr l] 
  42. (defun nthelem(n l) (nth (- n 1) l))
  43. (defun add fexpr(l)(eval(cons '+ l]             
  44. (defun add1(n)(+ 1 n))
  45. (defun diff fexpr(l)(eval(cons '- l]
  46. (defun difference fexpr(l)(eval(cons '- l]
  47. (defun minus(n)(- 0 n))
  48. (defun product fexpr(l)(eval(cons '* l]
  49. (defun times fexpr(l)(eval(cons '* l] 
  50. (defun quotient fexpr(l)(eval(cons '/ l]
  51. (defun sub1(n)(- n 1))
  52. (defun evenp(n)(= (mod n 2) 0))
  53. (defun minusp(n)(< n 0))
  54. (defun oddp(n)(= (mod n 2) 1))
  55. (defun onep(n)(= 1 n))
  56. (defun plusp(n)(> n 0))
  57. (defun zerop(n)(= n 0))
  58. (defun infile(f)(fileopen f 'r)) 
  59. (defun character-index(a c)(prog(n)(setq n 1 a(explode a))(cond((floatp c)(setq c(ascii c))))nxt:(cond((null a)(return nil)))(cond((eq(car a)c)(return n)))(setq n(+ n 1)a(cdr a))(go nxt:]  
  60.     
  61. ; 
  62. ; Some simple Turtle Graphics Routines to demonstrate PC-LISP. Remember that
  63. ; the graphics commands go though the BIOS so they are portable but slow.
  64. ;                     
  65.  
  66. (defun TurtleGraphicsUp()   (#scrmde# 6) (#scrsap# 0) (TurtleCenter))    
  67. (defun TurtleGraphicsDown() (#scrmde# 2))
  68. (defun TurtleCenter()       (setq Lastx 100 Lasty 100 Heading 1.570796372))
  69. (defun TurtleRight(n)       (setq Heading (+ Heading (* n 0.01745329))))
  70. (defun TurtleLeft(n)        (setq Heading (- Heading (* n 0.01745329))))
  71.  
  72. (defun TurtleForward(n) 
  73.       (setq Newx(+ Lastx(*(cos Heading)n))Newy(+ Lasty(*(sin Heading)n)))
  74.       (#scrline#(* Lastx 3.2) Lasty (* Newx 3.2) Newy 1)
  75.       (setq Lastx Newx Lasty Newy)
  76. )
  77.  
  78. ;
  79. ; end of Turtle Graphics primitives, start of Graphics demonstration code
  80. ; you can cut this out if you like and leave the Turtle primitives intact.
  81. ;
  82.  
  83. (defun Line_T(n)    
  84.     (TurtleForward n) (TurtleRight 180)
  85.     (TurtleForward (/ n 4))    
  86. )
  87.     
  88. (defun Square(n)
  89.     (TurtleForward n)  (TurtleRight 90)    
  90.     (TurtleForward n)  (TurtleRight 90)    
  91.     (TurtleForward n)  (TurtleRight 90)    
  92.     (TurtleForward n)            
  93. )
  94.  
  95. (defun Triangle(n)
  96.     (TurtleForward n)  (TurtleRight 120)
  97.     (TurtleForward n)  (TurtleRight 120)
  98.     (TurtleForward n)
  99. )
  100.  
  101. (defun Make(ObjectFunc Size times skew)    
  102.       (prog()       
  103.        TOP:(cond ((= times 0) (return)))
  104.        (ObjectFunc Size) 
  105.        (TurtleRight skew)
  106.        (setq times (- times 1))
  107.        (go TOP:)    
  108.        )
  109. )
  110.  
  111. (defun GraphicsDemo()
  112.        (TurtleGraphicsUp) 
  113.        (Make Square 40 18 5) (Make Square 60 18 5)
  114.        (gc)                            ; idle work
  115.        (TurtleGraphicsUp) 
  116.        (Make Triangle 40 18 5) (Make Triangle 60 18 5)
  117.        (gc)                            ; idle work
  118.        (TurtleGraphicsUp) 
  119.        (Make Line_T 80 50 10)
  120.        (gc)                            ; idle work
  121.        (TurtleGraphicsDown)
  122. )
  123.  
  124.